home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / backend / box.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  16.6 KB  |  360 lines  |  [TEXT/CCL2]
  1. ;;; box.scm -- determine which expressions need to be boxed
  2. ;;;
  3. ;;; author  :  Sandra Loosemore
  4. ;;; date    :  03 Apr 1993
  5. ;;;
  6. ;;; 
  7. ;;; This phase determines whether expressions need to be boxed or unboxed.
  8. ;;;
  9. ;;; In the case of an expression that needs to be boxed, it determines 
  10. ;;; whether it can be evaluated eagerly and boxed or whether a delay
  11. ;;; must be constructed.
  12. ;;;
  13. ;;; In the case of an expression that needs to be unboxed, it determines
  14. ;;; whether it is already known to have been evaluated and
  15.             delay-complexity)))
  16.         ))
  17.     (values
  18.       (if unboxed?
  19.       (note-already-forced object result)
  20.       result)
  21.       complexity)))
  22.  
  23.  
  24.  
  25.  
  26. ;;;======================================================================
  27. ;;; Code walk
  28. ;;;======================================================================
  29.  
  30.  
  31. (define *local-function-calls* '())
  32.  
  33. (define-flic-walker box-analysis (object already-forced uninitialized))
  34.  
  35. (define-box-analysis flic-lambda (object already-forced uninitialized)
  36.   (do-box-analysis (flic-lambda-body object) already-forced uninitialized '#t)
  37.   (values already-forced 0))
  38.  
  39. (define-box-analysis flic-let (object already-forced uninitialized)
  40.   (let ((bindings    (flic-let-bindings object)))
  41.     (dynamic-let ((*local-function-calls*  (dynamic *local-function-calls*)))
  42.       (dolist (var bindings)
  43.     ;; Note local functions
  44.     (when (and (not (var-toplevel? var))
  45.            (is-type? 'flic-lambda (var-value var))
  46.            (not (var-standard-refs? var)))
  47.       (push (cons var '()) (dynamic *local-function-calls*))))
  48.       (multiple-value-bind (already-forced complexity)
  49.       (box-analysis-let-aux object already-forced uninitialized)
  50.     (dolist (var bindings)
  51.       ;; Go back and reexamine local functions to see whether
  52.       ;; we can make more arguments strict, based on the values
  53.       ;; the function is actually called with.
  54.       (let ((stuff  (assq var (dynamic *local-function-calls*))))
  55.         (when stuff
  56.           (maybe-make-more-arguments-strict var (cdr stuff)))))
  57.     (values already-forced complexity)))))
  58.  
  59. (define (box-analysis-let-aux object already-forced uninitialized)
  60.   (let ((recursive?  (flic-let-recursive? object))
  61.     (bindings    (flic-let-bindings object))
  62.     (body        (flic-let-body object)))
  63.     (when recursive? (setf uninitialized (append bindings uninitialized)))
  64.     (dolist (var bindings)
  65.       (let* ((value   (var-value var))
  66.          (strict? (var-strict? var))
  67.          (result  (do-box-analysis value already-forced uninitialized
  68.                        strict?)))
  69.     (cond (strict?
  70.            ;; Propagate information about things forced.
  71.            (setf already-forced result))
  72.           ((and (flic-exp-cheap? value)
  73.             (flic-exp-strict-result? value)
  74.             (or (not (var-toplevel? var))
  75.             (not (def-exported? var))))
  76.            ;; The value expression is cheap unboxed value, so mark
  77.            ;; the variable as strict.
  78.            ;; We have to be careful with exported top-level definitions,
  79.                ;; though.  Always make these boxed so that forward
  80.            ;; references to them (via interface files) will work.
  81.            ;; This shouldn't be a problem with forward references 
  82.            ;; to locally defined variables, though, because their
  83.            ;; values should never turn out to be "cheap".
  84.            (setf (var-strict? var) '#t)
  85.            (setf (flic-exp-unboxed? value) '#t))))
  86.       (when recursive? (pop uninitialized)))
  87.     ;; *** Could be smarter about computing complexity.
  88.     (values
  89.       (do-box-analysis body already-forced uninitialized '#t)
  90.       '#f)))
  91.  
  92. (define (maybe-make-more-arguments-strict var calls)
  93.   (setf (var-strictness var)
  94.     (maybe-make-more-arguments-strict-aux
  95.       (flic-lambda-vars (var-value var))
  96.       calls)))
  97.  
  98. (define (maybe-make-more-arguments-strict-aux vars calls)
  99.   (if (null? vars)
  100.       '()
  101.       (let ((var  (car vars)))
  102.     ;; If the variable is not already strict, check to see
  103.     ;; whether it's always called with "cheap" arguments.
  104.     (when (and (not (var-strict? var))
  105.            (every-1 (lambda (call)
  106.                   (exp-would-be-cheap? (car call) var))
  107.                 calls))
  108.       (setf (var-strict? var) '#t)
  109.       (dolist (call calls)
  110.         (setf (flic-exp-unboxed? (car call)) '#t)))
  111.     (cons (var-strict? var)
  112.           (maybe-make-more-arguments-strict-aux
  113.            (cdr vars)
  114.            (map (function cdr) calls))))
  115.     ))
  116.  
  117.  
  118. ;;; Look for one special fixed-point case: argument used as counter-type
  119. ;;; variable.  Otherwise ignore fixed points.
  120.  
  121. (define (exp-would-be-cheap? exp var)
  122.   (or (and (flic-exp-cheap? exp)
  123.        (flic-exp-strict-result? exp))
  124.       (and (is-type? 'flic-ref exp)
  125.        (eq? (flic-ref-var exp) var))
  126.       (and (is-type? 'flic-app exp)
  127.        (is-type? 'flic-ref (flic-app-fn exp))
  128.        (var-complexity (flic-ref-var (flic-app-fn exp)))
  129.        (every-1 (lambda (a) (exp-would-be-cheap? a var))
  130.             (flic-app-args exp)))
  131.       ))
  132.  
  133.  
  134.  
  135. (define-box-analysis flic-app (object already-forced uninitialized)
  136.   (let ((fn         (flic-app-fn object))
  137.     (args       (flic-app-args object))
  138.     (saturated? (flic-app-saturated? object)))
  139.     (cond ((and saturated? (is-type? 'flic-ref fn))
  140.        (let* ((var    (flic-ref-var fn))
  141.           (stuff  (assq var (dynamic *local-function-calls*))))
  142.          (when stuff
  143.            (push args (cdr stuff)))
  144.          (box-analysis-app-aux
  145.            (var-strictness var) (var-complexity var)
  146.            args already-forced uninitialized)))
  147.       ((and saturated? (is-type? 'flic-pack fn))
  148.        (box-analysis-app-aux
  149.          (con-slot-strict? (flic-pack-con fn)) pack-complexity
  150.          args already-forced uninitialized))
  151.       (else
  152.        ;; The function is going to be forced but all the arguments
  153.        ;; are non-strict.
  154.        (dolist (a args)
  155.          (do-box-analysis a already-forced uninitialized '#f))
  156.        (values 
  157.          (do-box-analysis fn already-forced uninitialized '#t)
  158.          '#f))
  159.       )))
  160.       
  161.  
  162.  
  163. ;;; Propagation of already-forced information depends on whether or
  164. ;;; not the implementation evaluates function arguments in left-to-right
  165. ;;; order.  If not, we can still propagate this information upwards.
  166.  
  167. (define (box-analysis-app-aux
  168.        strictness complexity args already-forced uninitialized)
  169.   (let ((result   already-forced))
  170.     (dolist (a args)
  171.       (let ((strict?  (pop strictness)))
  172.     (multiple-value-bind (new-result new-complexity)
  173.         (do-box-analysis a already-forced uninitialized strict?)
  174.       (when strict?
  175.         (setf result
  176.           (if left-to-right-evaluation
  177.               (setf already-forced new-result)
  178.               (union-already-forced
  179.                 new-result already-forced result))))
  180.       (setf complexity (add-complexity complexity new-complexity)))))
  181.     (values result complexity)))
  182.  
  183.  
  184. ;;; Treat references to variables declared in an interface files
  185. ;;; the same as forward references to uninitialized local variables.
  186.  
  187. ;;;  Jcp:  I have made it so that all outside variables are assumed to
  188. ;;;        unavailable.  This will prevent problems with initialization
  189. ;;;        order.  It remains to be seen how much this may degrade the
  190. ;;;        generated code.
  191.  
  192. (define-box-analysis flic-ref (object already-forced uninitialized)
  193.   (let ((var  (flic-ref-var object)))
  194.     (values
  195.       already-forced
  196.       (if (or (memq var uninitialized)
  197.           (not (eq? (def-unit var) (dynamic *unit*))))
  198.       '#f
  199.       0))))
  200.  
  201.  
  202. (define-box-analysis flic-const (object already-forced uninitialized)
  203.   (declare (ignore object uninitialized))
  204.   (values already-forced 0))
  205.  
  206. (define-box-analysis flic-pack (object already-forced uninitialized)
  207.   (declare (ignore object uninitialized))
  208.   (values already-forced 0))
  209.  
  210.  
  211. ;;; For case-block and and, already-forced information can be propagated 
  212. ;;; sequentially in the clauses.  But only the first expression is 
  213. ;;; guaranteed to be evaluated, so only it can propagate the information
  214. ;;; outwards.
  215.  
  216. (define-box-analysis flic-case-block (object already-forced uninitialized)
  217.   (values
  218.     (box-analysis-sequence
  219.       (flic-case-block-exps object) already-forced uninitialized)
  220.     '#f))
  221.  
  222. (define-box-analysis flic-and (object already-forced uninitialized)
  223.   (values
  224.     (box-analysis-sequence
  225.       (flic-and-exps object) already-forced uninitialized)
  226.     '#f))
  227.  
  228. (define (box-analysis-sequence exps already-forced uninitialized)
  229.   (let ((result
  230.       (setf already-forced
  231.         (do-box-analysis
  232.           (car exps) already-forced uninitialized '#t))))
  233.     (dolist (e (cdr exps))
  234.       (setf already-forced
  235.         (do-box-analysis e already-forced uninitialized '#t)))
  236.     (values result already-forced)))
  237.  
  238.  
  239. (define-box-analysis flic-return-from (object already-forced uninitialized)
  240.   (values
  241.     (do-box-analysis
  242.       (flic-return-from-exp object) already-forced uninitialized '#t)
  243.     '#f))
  244.  
  245.  
  246. ;;; For if, the test propagates to both branches and the result.
  247. ;;; Look for an important optimization:
  248. ;;; in (if (and e1 e2 ...) e-then e-else),
  249. ;;; e-then can inherit already-forced information from all of the ei
  250. ;;; rather than only from e1.
  251. ;;; *** Could be smarter about the complexity, I suppose....
  252. ;;; *** Also could intersect already-forced results from both
  253. ;;; *** branches.
  254.  
  255. (define-box-analysis flic-if (object already-forced uninitialized)
  256.   (if (is-type? 'flic-and (flic-if-test-exp object))
  257.       (box-analysis-if-and-aux object already-forced uninitialized)
  258.       (box-analysis-if-other-aux object already-forced uninitialized)))
  259.  
  260. (define (box-analysis-if-other-aux object already-forced uninitialized)
  261.   (setf already-forced
  262.     (do-box-analysis
  263.       (flic-if-test-exp object) already-forced uninitialized '#t))
  264.   (do-box-analysis (flic-if-then-exp object) already-forced uninitialized '#t)
  265.   (do-box-analysis (flic-if-else-exp object) already-forced uninitialized '#t)
  266.   (values already-forced '#f))
  267.  
  268. (define (box-analysis-if-and-aux object already-forced uninitialized)
  269.   (let* ((test-exp  (flic-if-test-exp object))
  270.      (subexps   (flic-and-exps test-exp))
  271.      (then-exp  (flic-if-then-exp object))
  272.      (else-exp  (flic-if-else-exp object)))
  273.     (setf (flic-exp-unboxed? test-exp) '#t)
  274.     (multiple-value-bind (result1 resultn)
  275.     (box-analysis-sequence subexps already-forced uninitialized)
  276.       (do-box-analysis then-exp resultn uninitialized '#t)
  277.       (do-box-analysis else-exp result1 uninitialized '#t)
  278.       (values result1 '#f))))
  279.  
  280.  
  281. (define-box-analysis flic-sel (object already-forced uninitialized)
  282.   (multiple-value-bind (result complexity)
  283.       (do-box-analysis
  284.         (flic-sel-exp object) already-forced uninitialized '#t)
  285.     (values result (add-complexity sel-complexity complexity))))
  286.  
  287. (define-box-analysis flic-is-constructor (object already-forced uninitialized)
  288.   (multiple-value-bind (result complexity)
  289.       (do-box-analysis
  290.         (flic-is-constructor-exp object) already-forced uninitialized '#t)
  291.     (values result (add-complexity is-constructor-complexity complexity))))
  292.  
  293. (define-box-analysis flic-con-number (object already-forced uninitialized)
  294.   (multiple-value-bind (result complexity)
  295.       (do-box-analysis
  296.         (flic-con-number-exp object) already-forced uninitialized '#t)
  297.     (values result (add-complexity con-number-complexity complexity))))
  298.  
  299. (define-box-analysis flic-void (object already-forced uninitialized)
  300.   (declare (ignore object uninitialized))
  301.   (values already-forced 0))
  302.  
  303.  
  304. ;;; This is very similar to app of flic-pack.  Strictness of slot update
  305. ;;; expressions comes from slot strictness of constructor, and the object
  306. ;;; being copied is always strict.
  307.  
  308. (define-box-analysis flic-update (object already-forced uninitialized)
  309.   (let* ((con    (flic-update-con object))
  310.      (strict (con-slot-strict? con))
  311.      (slots  (flic-update-slots object))
  312.      (exp    (flic-update-exp object)))
  313.     (multiple-value-bind (result complexity)
  314.     (do-box-analysis exp already-forced uninitialized '#t)
  315.       (setf already-forced result)
  316.       (dolist (s slots)
  317.     (let ((s?  (list-ref strict (car s))))
  318.       (multiple-value-bind (new-result new-complexity)
  319.           (do-box-analysis (cdr s) already-forced uninitialized s?)
  320.         (when s?
  321.           (setf result
  322.             (if left-to-right-evaluation
  323.             (setf already-forced new-result)
  324.                 (union-already-forced
  325.               new-result already-forced result))))
  326.         (setf complexity (add-complexity complexity new-complexity)))))
  327.       (values result complexity))))
  328.  
  329.  
  330.  
  331.  
  332. ;;;======================================================================
  333. ;;; Already-forced bookkeeping
  334. ;;;======================================================================
  335.  
  336.  
  337. ;;; For now, we only keep track of variables that have been forced,
  338. ;;; and not data structure accesses.
  339.  
  340. (define (already-forced? object already-forced)
  341.   (and (is-type? 'flic-ref object)
  342.        (memq (flic-ref-var object) already-forced)))
  343.  
  344. (define (note-already-forced object already-forced)
  345.   (if (is-type? 'flic-ref object)
  346.       (cons (flic-ref-var object) already-forced)
  347.       already-forced))
  348.  
  349. (define (union-already-forced new tail result)
  350.   (cond ((eq? new tail)
  351.      result)
  352.     ((memq (car new) result)
  353.      (union-already-forced (cdr new) tail result))
  354.     (else
  355.      (union-already-forced (cdr new) tail (cons (car new) result)))
  356.     ))
  357.  
  358.                       
  359.  
  360.